home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / prog / xlisp21.zip / INIT.LSP < prev    next >
Text File  |  1989-04-23  |  2KB  |  60 lines
  1. ; initialization file for XLISP 2.1
  2.  
  3. ; define some macros
  4. (defmacro defvar (sym &optional val)
  5.   `(if (boundp ',sym) ,sym (setq ,sym ,val)))
  6. (defmacro defparameter (sym val)
  7.   `(setq ,sym ,val))
  8. (defmacro defconstant (sym val)
  9.   `(setq ,sym ,val))
  10.  
  11. ; (makunbound sym) - make a symbol value be unbound
  12. (defun makunbound (sym) (setf (symbol-value sym) '*unbound*) sym)
  13.  
  14. ; (fmakunbound sym) - make a symbol function be unbound
  15. (defun fmakunbound (sym) (setf (symbol-function sym) '*unbound*) sym)
  16.  
  17. ; (mapcan fun list [ list ]...)
  18. (defmacro mapcan (&rest args) `(apply #'nconc (mapcar ,@args)))
  19.  
  20. ; (mapcon fun list [ list ]...)
  21. (defmacro mapcon (&rest args) `(apply #'nconc (maplist ,@args)))
  22.  
  23. ; (set-macro-character ch fun [ tflag ])
  24. (defun set-macro-character (ch fun &optional tflag)
  25.     (setf (aref *readtable* (char-int ch))
  26.           (cons (if tflag :tmacro :nmacro) fun))
  27.     t)
  28.  
  29. ; (get-macro-character ch)
  30. (defun get-macro-character (ch)
  31.   (if (consp (aref *readtable* (char-int ch)))
  32.     (cdr (aref *readtable* (char-int ch)))
  33.     nil))
  34.  
  35. ; (savefun fun) - save a function definition to a file
  36. (defmacro savefun (fun)
  37.   `(let* ((fname (strcat (symbol-name ',fun) ".lsp"))
  38.           (fval (get-lambda-expression (symbol-function ',fun)))
  39.           (fp (open fname :direction :output)))
  40.      (cond (fp (print (cons (if (eq (car fval) 'lambda)
  41.                                 'defun
  42.                                 'defmacro)
  43.                             (cons ',fun (cdr fval))) fp)
  44.                (close fp)
  45.                fname)
  46.            (t nil))))
  47.  
  48. ; (debug) - enable debug breaks
  49. (defun debug ()
  50.        (setq *breakenable* t))
  51.  
  52. ; (nodebug) - disable debug breaks
  53. (defun nodebug ()
  54.        (setq *breakenable* nil))
  55.  
  56. ; initialize to enable breaks but no trace back
  57. (setq *breakenable* t)
  58. (setq *tracenable* nil)
  59.  
  60.